home *** CD-ROM | disk | FTP | other *** search
/ Shareware Grab Bag / Shareware Grab Bag.iso / 050 / madtrb7.arc / CRFONTS.PAS < prev    next >
Pascal/Delphi Source File  |  1985-02-23  |  16KB  |  415 lines
  1. PROGRAM FONTS(INPUT,OUTPUT);
  2. CONST
  3.       KEY1='TOGGLE'; KEY2=' '; KEY3='SHLT'; KEY4='SHRT'; KEY5='SHUP';
  4.       KEY6='SHDN'; KEY7='CLR'; KEY8='FILL'; KEY9='#'; KEY10='MENU';
  5.       KEYINS='+1'; KEYDEL='-1';
  6.  
  7.       MAXFONT=255; BIT1=0; BIT8=7;
  8.  
  9.       DOT=22; HLINE=205; VLINE=186; LUC=201; RUC=187; RLC=188; LLC=200;
  10.  {                   ═          ║        ╔        ╗        ╝        ╚    }
  11.  
  12.       { LOCATION OF FRAME. LUCR0 & LUCC0 LOCATE UPPER LEFT-HAND CORNER, WHILE
  13.         HSTEP & VSTEP DETERMINE ITS SIZE. }
  14.  
  15.       LUCR0=3; LUCC0=4; HSTEP=2; VSTEP=1;
  16.  
  17.       MENUR=5; MENUC=40;
  18.  
  19. TYPE
  20.     BIGSTR = STRING[80];
  21.     BYTEBITS = BIT1..BIT8;
  22.     PATTERN_SET = SET OF BYTEBITS; CHAR_PATTERN = ARRAY[1..8] OF PATTERN_SET;
  23.     FILE_NAME_TYPE = STRING[14];
  24.     CHAR_PATTERN_FILE = FILE OF CHAR_PATTERN;
  25.     REG_LENGTH = (REG_WORD,REG_BYTE);
  26.     REGPACK = RECORD CASE REG_LENGTH OF
  27.                      REG_WORD: (AX,BX,CX,DX,BPX,SIX,DIX,DSX,ESX,FLAGX: INTEGER);
  28.                      REG_BYTE: (AL,AH,BL,BH,CL,CH,DL,DH:BYTE;
  29.                                 BP,SI,DI,DS,ES,FLAG:INTEGER);
  30.                      END;
  31.  
  32.    KEYS = (NOKEY,NOTFCT,
  33.            F1,F2,F3,F4,F5,F6,F7,F8,F9,F10,
  34.            HOME,UP,PGUP,LT,RT,EN,DN,PGDN,INS,DEL);
  35.  
  36.    ON_OFF = (ON,OFF);
  37.  
  38. VAR
  39.     FONTS: ARRAY[0..MAXFONT] OF CHAR_PATTERN;
  40.     FILENAME1,FILENAME2: FILE_NAME_TYPE;
  41.     FILE1,FILE2:CHAR_PATTERN_FILE;
  42.     FONTNO,FONTNR,FONTNC,XYR,XYC: INTEGER;
  43.     KEY:KEYS; CH,CHX:CHAR;
  44.     I,J:INTEGER;
  45.     CURROW,CURCOL:INTEGER; { CURRENT LOGICAL CURSOR POSITION }
  46.     QUIT:BOOLEAN;
  47.  
  48. {*************************** P R O C E D U R E S  **************************}
  49. PROCEDURE REVERSE; { CHANGES OUTPUT TO REVERSE VIDEO }
  50.           BEGIN TEXTCOLOR(BLACK); TEXTBACKGROUND(WHITE); END;
  51.  
  52. PROCEDURE NORMAL; { CHANGES OUTPUT TO NORMAL VIDEO }
  53.           BEGIN TEXTCOLOR(WHITE); TEXTBACKGROUND(BLACK); END;
  54.  
  55. FUNCTION GETKEY(VAR CHX,CH:CHAR): KEYS;
  56. CONST ESC=27;
  57. BEGIN
  58. IF KEYPRESSED THEN BEGIN  { READ KEYBOARD, AND MAP INTO 'KEYS' TYPE }
  59.    READ(KBD,CH); CHX:=CHR(0);
  60.    IF ORD(CH)=ESC THEN
  61.       IF KEYPRESSED THEN BEGIN CHX:=CH; READ(KBD,CH) END;
  62.  
  63.    IF CHX=CHR(0) THEN GETKEY:=NOTFCT
  64.    ELSE CASE CH OF
  65.         ';':  GETKEY:=F1;
  66.         '<':  GETKEY:=F2;
  67.         '=':  GETKEY:=F3;
  68.         '>':  GETKEY:=F4;
  69.         '?':  GETKEY:=F5;
  70.         '@':  GETKEY:=F6;
  71.         'A':  GETKEY:=F7;
  72.         'B':  GETKEY:=F8;
  73.         'C':  GETKEY:=F9;
  74.         'D':  GETKEY:=F10;
  75.         'G':  GETKEY:=HOME;
  76.         'H':  GETKEY:=UP;
  77.         'I':  GETKEY:=PGUP;
  78.         'K':  GETKEY:=LT;
  79.         'M':  GETKEY:=RT;
  80.         'O':  GETKEY:=EN;
  81.         'P':  GETKEY:=DN;
  82.         'Q':  GETKEY:=PGDN;
  83.         'R':  GETKEY:=INS;
  84.         'S':  GETKEY:=DEL;
  85.         ELSE GETKEY:=NOTFCT;
  86.         END { CASE }
  87.     END {KEYPRESSED}
  88. ELSE GETKEY:=NOKEY;
  89. END; {GETKEY}
  90.  
  91. PROCEDURE BLINKVIDEO;
  92.           BEGIN TEXTCOLOR(WHITE+BLINK) END;
  93.  
  94. FUNCTION LOCATE_ROW(I:INTEGER): INTEGER;
  95.          BEGIN LOCATE_ROW:=LUCR0+VSTEP*I; END;
  96.  
  97. FUNCTION LOCATE_COL(I:BYTEBITS): INTEGER;
  98.          BEGIN LOCATE_COL:=LUCC0+HSTEP*(I+1); END;
  99.  
  100. PROCEDURE GOTORC(ROW,COL:INTEGER);
  101.           BEGIN GOTOXY(COL,ROW); END;
  102.  
  103. {**** REVERSE THE BITS IN A SET TYPE.  THE BIT NUMBERING FOR GRAPHICS
  104.       PATTERNS IS A MIRROR IMAGE OF THE BIT NUMBERING FOR PASCAL SETS. }
  105. PROCEDURE REVFONT(FONT:CHAR_PATTERN;VAR TFONT:CHAR_PATTERN);
  106. VAR I:INTEGER;
  107.  
  108. {*} PROCEDURE REVSET(PSET:PATTERN_SET;VAR TPSET:PATTERN_SET);
  109.     VAR I:BYTEBITS;
  110.     BEGIN TPSET:=[];
  111.           FOR I:=BIT1 TO BIT8 DO IF I IN PSET THEN TPSET:=TPSET + [BIT8-I];
  112.     END;
  113.  
  114. BEGIN
  115.    FOR I:=1 TO 8 DO REVSET(FONT[I],TFONT[I]);
  116. END;
  117.  
  118. PROCEDURE DISPLAY_COORD(ROW:INTEGER;COL:BYTEBITS);
  119. VAR X,Y:INTEGER;
  120. BEGIN X:=WHEREX; Y:=WHEREY; GOTORC(XYR,XYC); REVERSE;
  121.       WRITE(' ',ROW:1,',',COL+1:1,' '); NORMAL;
  122.       GOTOXY(X,Y); END;
  123.  
  124. PROCEDURE DOT_CLR(I:INTEGER;J:BYTEBITS; CURSOR:ON_OFF);
  125.           BEGIN FONTS[FONTNO][I]:= FONTS[FONTNO][I] - [J];
  126.                 GOTORC(LOCATE_ROW(I),LOCATE_COL(J));
  127.                 IF CURSOR=ON THEN BEGIN
  128.                    DISPLAY_COORD(I,J); BLINKVIDEO; WRITE(CHR(DOT)); NORMAL; END
  129.                 ELSE WRITE(' ');
  130.           END;
  131.  
  132. PROCEDURE DOT_SET(I:INTEGER;J:BYTEBITS; CURSOR:ON_OFF);
  133.           BEGIN FONTS[FONTNO,I] := FONTS[FONTNO,I] + [J];
  134.                 GOTORC(LOCATE_ROW(I),LOCATE_COL(J));
  135.                 IF CURSOR=ON THEN BEGIN
  136.                    DISPLAY_COORD(I,J); HIGHVIDEO END
  137.                 ELSE LOWVIDEO;
  138.                 WRITE(CHR(DOT));
  139.           NORMAL;
  140.           END;
  141.  
  142. PROCEDURE DOT_CURSOR(ROW:INTEGER;COL:BYTEBITS;CURSOR:ON_OFF);
  143.           BEGIN GOTORC(LOCATE_ROW(ROW),LOCATE_COL(COL));
  144.                 IF COL IN FONTS[FONTNO,ROW] THEN BEGIN
  145.                    IF CURSOR=ON THEN BEGIN
  146.                       DISPLAY_COORD(ROW,COL); HIGHVIDEO END
  147.                    ELSE LOWVIDEO; WRITE(CHR(DOT)) END
  148.                 ELSE IF CURSOR=ON THEN BEGIN
  149.                         DISPLAY_COORD(ROW,COL);BLINKVIDEO; WRITE(CHR(DOT)); END
  150.                      ELSE WRITE(' ');
  151.            NORMAL;
  152.            END;
  153.  
  154. PROCEDURE LINE25; { PRINTOUT THE LINE 25 INFORMATION }
  155. VAR KEYNO:INTEGER;
  156.   PROCEDURE WRITEKEY(KEY:BIGSTR);
  157.             BEGIN NORMAL; KEYNO:=KEYNO+1;
  158.             IF KEYNO<>1 THEN WRITE(' ');
  159.             IF KEYNO<=10 THEN WRITE(KEYNO:1)
  160.             ELSE IF KEYNO=11 THEN WRITE('INS') ELSE WRITE('DEL');
  161.             REVERSE; WRITE(KEY); NORMAL; END;
  162.  
  163. BEGIN
  164.    GOTOXY(1,25);  KEYNO:=0;
  165.    WRITEKEY(KEY1); WRITEKEY(KEY2); WRITEKEY(KEY3); WRITEKEY(KEY4); WRITEKEY(KEY5);
  166.    WRITEKEY(KEY6); WRITEKEY(KEY7); WRITEKEY(KEY8); WRITEKEY(KEY9); WRITEKEY(KEY10);
  167.    WRITEKEY(KEYINS); WRITEKEY(KEYDEL);
  168. END; {LINE25}
  169.  
  170. PROCEDURE DISPLAY_BORDER;
  171. VAR I,RTCOL,BTMROW:INTEGER;
  172. BEGIN
  173.    HIGHVIDEO;
  174.  
  175.    { WRITE OUT CORNER CHARACTERS }
  176.    GOTORC(LUCR0,LUCC0); WRITE(CHR(LUC));
  177.    RTCOL:=LUCC0+9*HSTEP; GOTORC(LUCR0,RTCOL); WRITE(CHR(RUC));
  178.    BTMROW:=LUCR0+9*VSTEP; GOTORC(BTMROW,LUCC0); WRITE(CHR(LLC));
  179.    GOTORC(BTMROW,RTCOL); WRITE(CHR(RLC));
  180.  
  181.    { WRITE OUT LINES OF FRAME }
  182.    FOR I:=LUCC0+1 TO RTCOL-1 DO BEGIN
  183.        GOTORC(LUCR0,I); WRITE(CHR(HLINE)); GOTORC(BTMROW,I); WRITE(CHR(HLINE)); END;
  184.    FOR I:=LUCR0+1 TO BTMROW-1 DO BEGIN
  185.        GOTORC(I,LUCC0); WRITE(CHR(VLINE)); GOTORC(I,RTCOL); WRITE(CHR(VLINE)); END;
  186.  
  187.    { INITIALIZE THE SCREEN POSITION OF THE FONT NUMBER }
  188.    FONTNR:=LUCR0-1; FONTNC:=RTCOL-4;
  189.    XYR:=FONTNR; XYC:=LUCC0;
  190.  
  191. END; { DISPLAY_BORDER }
  192.  
  193. PROCEDURE DISPLAY_FONTNO(FONTNO:INTEGER);
  194.           BEGIN REVERSE; GOTORC(FONTNR,FONTNC); WRITE(' ',FONTNO:3,' '); NORMAL; END;
  195.  
  196. PROCEDURE DISPLAY_FONTS(FONT:CHAR_PATTERN);
  197. VAR I,ROW:INTEGER; COL,J:BYTEBITS;
  198. BEGIN
  199.     LOWVIDEO;
  200.     FOR I:=1 TO 8 DO BEGIN
  201.         ROW:=LOCATE_ROW(I); { GET SCREEN POSITION OF THE Ith ROW }
  202.         FOR J:=BIT1 TO BIT8 DO BEGIN
  203.             COL:=LOCATE_COL(J); { GET SCREEN POSITION OF THE Jth COLUMN }
  204.             GOTORC(ROW,COL);
  205.             IF J IN FONT[I] THEN WRITE(CHR(DOT)) ELSE WRITE(' ');
  206.             END;
  207.         END;
  208.     CURROW:=1; CURCOL:=BIT1; DOT_CURSOR(CURROW,CURCOL,ON);
  209. END; { DISPLAY A FONT }
  210.  
  211. PROCEDURE DISPLAY_FONT(FONTNO:INTEGER);
  212. BEGIN DISPLAY_FONTS(FONTS[FONTNO]); END;
  213.  
  214. PROCEDURE MENUS;
  215. LABEL TO_LBL,FROM_LBL,NUM_LBL;
  216. CONST ROMOFS=$FA6E; ROMSEG=$F000;
  217. VAR CMD:1..4; QROW:INTEGER;
  218.     FONT:CHAR_PATTERN;
  219.     SFONT,DFONT,CODE,NUM,I,STRPOS,XPOS,YPOS:INTEGER;
  220.     INSTRING: STRING[80];
  221.     ROM:BOOLEAN;
  222.     PATTERN: PATTERN_SET; MEMBYTE:BYTE ABSOLUTE PATTERN;
  223.     ANS:CHAR;
  224.     FILENAME:FILE_NAME_TYPE;
  225.  
  226.   {*}PROCEDURE WRITE_OPTION(ROW:INTEGER;STR:BIGSTR);
  227.   BEGIN
  228.      GOTORC(ROW,MENUC); WRITE(STR); END;
  229.   {*}PROCEDURE CLEAR_ROWS(ROW:INTEGER);
  230.   VAR I:INTEGER;
  231.   BEGIN
  232.       FOR I:=ROW TO 24 DO BEGIN GOTORC(I,MENUC); CLREOL; END;
  233.   END;
  234.   {*}FUNCTION OPEN_INPUT_FILE(VAR FILEVAR:CHAR_PATTERN_FILE;FILENAME:FILE_NAME_TYPE):BOOLEAN;
  235.   BEGIN
  236.       OPEN_INPUT_FILE:=TRUE;
  237.       ASSIGN(FILEVAR,FILENAME); {$I-} RESET(FILEVAR); {$I+}
  238.       IF IORESULT <> 0 THEN BEGIN
  239.          GOTORC(24,MENUC); WRITE('NON-EXISTENT FILE'); OPEN_INPUT_FILE:=FALSE END;
  240.   END;
  241.   {*}PROCEDURE STRIP_LBLANKS(VAR STR:BIGSTR);
  242.      VAR I:INTEGER; DONE:BOOLEAN;
  243.      BEGIN DONE:=FALSE;
  244.            WHILE (STR[1]=' ') AND (NOT DONE) DO
  245.                  BEGIN MOVE(STR[2],STR[1],LENGTH(STR)-1);
  246.                        STR[0]:=CHR(ORD(STR[0])-1);
  247.                        IF ORD(STR[0])<=0 THEN DONE:=TRUE; END;
  248.         END; { STRIP }
  249.  
  250. BEGIN
  251.      WRITE_OPTION(MENUR,'1. QUIT');
  252.      WRITE_OPTION(MENUR+1,'2. READ FILE');
  253.      WRITE_OPTION(MENUR+2, '3. WRITE FILE');
  254.      WRITE_OPTION(MENUR+3,'4. COPY FONTS');
  255.      WRITE_OPTION(MENUR+5,'COMMAND: ');
  256.      READ(CMD);
  257.      QROW:=MENUR+7; CLEAR_ROWS(QROW);
  258.      CASE CMD OF
  259.      1: BEGIN GOTORC(QROW,MENUC); WRITE('SURE ? (Y/N): ');
  260.               READ(ANS); IF (ANS='y') OR (ANS='Y') THEN QUIT:=TRUE; END;
  261.      2: BEGIN
  262.           GOTORC(QROW,MENUC); WRITE('INPUT FILENAME:'); READ(FILENAME1);
  263.           IF OPEN_INPUT_FILE(FILE1,FILENAME1) THEN BEGIN
  264.              DFONT:=0; WHILE NOT EOF(FILE1) DO BEGIN
  265.                               READ(FILE1,FONT);
  266.                               REVFONT(FONT,FONTS[DFONT]);
  267.                               DFONT:=(DFONT+1) MOD 256; END;
  268.              CLOSE (FILE1); END;
  269.           WRITE(' OK'); DISPLAY_FONT(FONTNO); END;
  270.      3: BEGIN
  271.           GOTORC(QROW,MENUC);
  272.           IF LENGTH(FILENAME2)=0 THEN FILENAME2:=FILENAME1;
  273.           WRITE('OUTPUT FILENAME (',FILENAME2,'): '); READ(FILENAME);
  274.           IF LENGTH(FILENAME)<>0 THEN FILENAME2:=FILENAME;
  275.           ASSIGN(FILE2,FILENAME2); REWRITE(FILE2);
  276.           FOR SFONT:=0 TO MAXFONT DO BEGIN
  277.               REVFONT(FONTS[SFONT],FONT); WRITE(FILE2,FONT); END;
  278.           CLOSE(FILE2); WRITE(' OK'); END;
  279.      4: BEGIN
  280. TO_LBL:
  281.            GOTORC(QROW,MENUC); WRITE('TO (',FONTNO:1,'):');
  282.            DFONT:=FONTNO; {$I-} READ(DFONT); {$I+}
  283.            IF IORESULT <> 0 THEN GOTO TO_LBL;
  284.  
  285. FROM_LBL:  GOTORC(QROW+1,MENUC); WRITE('FROM (<FONT#> | ROM <FONT#>):');
  286.            XPOS:=WHEREX; YPOS:=WHEREY; READ(INSTRING);
  287.            { PARSE INSTRING; IF CONTAINS WORD 'ROM' THEN COPY FROM ROM }
  288.            STRPOS:=POS('ROM',INSTRING); ROM:=FALSE;
  289.            IF STRPOS<>0 THEN BEGIN ROM:=TRUE; DELETE(INSTRING,STRPOS,3);END;
  290.            STRIP_LBLANKS(INSTRING); VAL(INSTRING,SFONT,CODE);
  291.            IF CODE<>0 THEN BEGIN
  292.               GOTOXY(XPOS,YPOS); CLREOL; GOTO FROM_LBL; END;
  293.  
  294. NUM_LBL:
  295.            GOTORC(QROW+2,MENUC); WRITE('NUM (1):'); NUM:=1; {$I-}READ(NUM); {$I+}
  296.            IF IORESULT <> 0 THEN GOTO NUM_LBL;
  297.  
  298.            IF ROM THEN BEGIN
  299.               MOVE(MEM[ROMSEG:(ROMOFS+SFONT*8)],FONTS[DFONT],NUM*8);
  300.               FOR I:=DFONT TO DFONT+NUM-1 DO {REVERSE BIT PATTERNS}
  301.                   REVFONT(FONTS[I],FONTS[I]);
  302.               END
  303.            ELSE MOVE(FONTS[SFONT],FONTS[DFONT],NUM*8);
  304.            WRITE(' OK'); DISPLAY_FONT(FONTNO); END; { 4 }
  305.  
  306.       ELSE { DO NOTHING } END; { CASE }
  307. END; { MENUS }
  308.  
  309. PROCEDURE PERFORM(KEY:KEYS); { MAJOR ROUTINE FOR EXECUTING THE NON-MENU COMMANDS }
  310. VAR I:INTEGER; J:BYTEBITS;
  311. BEGIN
  312.     CASE KEY OF
  313.     F1: { TURN ON BIT }
  314.         IF CURCOL IN FONTS[FONTNO,CURROW] THEN DOT_CLR(CURROW,CURCOL,ON)
  315.                                           ELSE DOT_SET(CURROW,CURCOL,ON);
  316.     F2: { NOTHING IMPLEMENTED };
  317.     F3: BEGIN { SHIFT LEFT }
  318.         FOR J:=BIT1 TO BIT8 DO FOR I:=1 TO 8 DO
  319.             IF J=BIT8 THEN DOT_CLR(I,J,OFF)
  320.             ELSE IF J+1 IN FONTS[FONTNO,I] THEN DOT_SET(I,J,OFF)
  321.                                            ELSE DOT_CLR(I,J,OFF);
  322.         DOT_CURSOR(CURROW,CURCOL,ON); END;
  323.     F4: BEGIN { SHIFT RIGHT }
  324.         FOR J:=BIT8 DOWNTO BIT1 DO FOR I:=1 TO 8 DO
  325.             IF J=BIT1 THEN DOT_CLR(I,J,OFF)
  326.             ELSE IF J-1 IN FONTS[FONTNO,I] THEN DOT_SET(I,J,OFF)
  327.                                            ELSE DOT_CLR(I,J,OFF);
  328.         DOT_CURSOR(CURROW,CURCOL,ON); END;
  329.     F5: BEGIN { SHIFT UP }
  330.         FOR I:=1 TO 8 DO FOR J:=BIT1 TO BIT8 DO
  331.             IF I=8 THEN DOT_CLR(I,J,OFF)
  332.             ELSE IF J IN FONTS[FONTNO,I+1] THEN DOT_SET(I,J,OFF)
  333.                                            ELSE DOT_CLR(I,J,OFF);
  334.         DOT_CURSOR(CURROW,CURCOL,ON); END;
  335.     F6: BEGIN { SHIFT DOWN }
  336.         FOR I:=8 DOWNTO 1 DO FOR J:=BIT1 TO BIT8 DO
  337.             IF I=1 THEN DOT_CLR(I,J,OFF)
  338.             ELSE IF J IN FONTS[FONTNO,I-1] THEN DOT_SET(I,J,OFF)
  339.                                            ELSE DOT_CLR(I,J,OFF);
  340.         DOT_CURSOR(CURROW,CURCOL,ON); END;
  341.     F7: BEGIN { CLEAR FONT }
  342.         FOR I:=1 TO 8 DO FOR J:=BIT1 TO BIT8 DO DOT_CLR(I,J,OFF);
  343.         CURROW:=1; CURCOL:=0; DOT_CURSOR(1,0,ON); END;
  344.     F8: BEGIN { FILL FONT }
  345.         FOR I:=1 TO 8 DO FOR J:=BIT1 TO BIT8 DO DOT_SET(I,J,OFF);
  346.         CURROW:=1; CURCOL:=0; DOT_CURSOR(1,0,ON); END;
  347.     F9: { GET NEW FONT NUMBER TO DISPLAY }
  348.         BEGIN GOTORC(FONTNR,FONTNC); REVERSE; READ(FONTNO);
  349.         DISPLAY_FONTNO(FONTNO); DISPLAY_FONT(FONTNO) END;
  350.     INS:{ NEXT FONT }
  351.         BEGIN FONTNO:=(FONTNO+1)MOD 256;
  352.         DISPLAY_FONTNO(FONTNO); DISPLAY_FONT(FONTNO) END;
  353.     DEL:{ PREVIOUS FONT }
  354.         BEGIN FONTNO:=(FONTNO+255) MOD 256;
  355.         DISPLAY_FONTNO(FONTNO); DISPLAY_FONT(FONTNO) END;
  356.     F10:{ MENUS }
  357.         MENUS;
  358.     { CURSOR MOVEMENT ROUTINES }
  359.     HOME: BEGIN DOT_CURSOR(CURROW,CURCOL,OFF);
  360.                 CURROW:=(CURROW+6)MOD 8+1; CURCOL:=(CURCOL+7)MOD 8;
  361.                 DOT_CURSOR(CURROW,CURCOL,ON); END;
  362.     UP:   BEGIN DOT_CURSOR(CURROW,CURCOL,OFF);
  363.                 CURROW:=(CURROW+6)MOD 8+1;
  364.                 DOT_CURSOR(CURROW,CURCOL,ON); END;
  365.     PGUP: BEGIN DOT_CURSOR(CURROW,CURCOL,OFF);
  366.                 CURROW:=(CURROW+6)MOD 8+1; CURCOL:=(CURCOL+1) MOD 8;
  367.                 DOT_CURSOR(CURROW,CURCOL,ON); END;
  368.     LT:   BEGIN DOT_CURSOR(CURROW,CURCOL,OFF);
  369.                 CURCOL:=(CURCOL+7)MOD 8;
  370.                 DOT_CURSOR(CURROW,CURCOL,ON); END;
  371.     RT:   BEGIN DOT_CURSOR(CURROW,CURCOL,OFF);
  372.                 CURCOL:=(CURCOL+1) MOD 8;
  373.                 DOT_CURSOR(CURROW,CURCOL,ON); END;
  374.     EN:   BEGIN DOT_CURSOR(CURROW,CURCOL,OFF);
  375.                 CURROW:=CURROW MOD 8+1; CURCOL:=(CURCOL+7)MOD 8;
  376.                 DOT_CURSOR(CURROW,CURCOL,ON); END;
  377.     DN:   BEGIN DOT_CURSOR(CURROW,CURCOL,OFF);
  378.                 CURROW:=CURROW MOD 8+1;
  379.                 DOT_CURSOR(CURROW,CURCOL,ON); END;
  380.     PGDN: BEGIN DOT_CURSOR(CURROW,CURCOL,OFF);
  381.                 CURROW:=CURROW MOD 8+1; CURCOL:=(CURCOL+1) MOD 8;
  382.                 DOT_CURSOR(CURROW,CURCOL,ON); END;
  383.     END;
  384. END; { PERFORM }
  385.  
  386. PROCEDURE CENTER_WRITE(ROW:INTEGER; STR:BIGSTR);
  387. VAR COL:INTEGER;
  388. BEGIN COL:=41-LENGTH(STR) DIV 2; GOTOXY(COL,ROW); WRITE(STR); END;
  389.  
  390. BEGIN  {************** MAIN PROGRAM ********************}
  391.     { SIGN ON }
  392.     CLRSCR; REVERSE;
  393.     CENTER_WRITE(8,' C R E A T E   F O N T S ');
  394.     CENTER_WRITE(10,' B Y ');
  395.     CENTER_WRITE(12, ' L .  J .  W I N K L E R ');
  396.     CENTER_WRITE(16,' COPYRIGHT 1984 LAWRENCE J. WINKLER ');
  397.     NORMAL; DELAY(4000); CLRSCR;
  398.  
  399.     { INITIALIZE VARIABLES }
  400.     FOR FONTNO:=0 TO MAXFONT DO FOR I:=1 TO 8 DO FONTS[FONTNO,I]:=[];
  401.     FONTNO:=0; CURROW:=1; CURCOL:=BIT1; QUIT:=FALSE;
  402.     FILENAME1:=''; FILENAME2:='';
  403.     LINE25;
  404.     DISPLAY_BORDER;
  405.     DISPLAY_FONTNO(FONTNO); DISPLAY_FONT(FONTNO);
  406.  
  407.     WHILE NOT QUIT DO
  408.           IF KEYPRESSED THEN BEGIN
  409.              KEY:=GETKEY(CHX,CH);
  410.              IF (KEY <> NOKEY) AND (KEY <> NOTFCT) THEN PERFORM(KEY);
  411.              END;
  412.  
  413.     GOTORC(24,10); WRITELN(' C R E A T E   F O N T S   TERMINATING');
  414.  
  415. END.